home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / makescrn.zip / MAKESCRN.PAS < prev   
Pascal/Delphi Source File  |  1989-08-27  |  11KB  |  449 lines
  1. PROGRAM MakeScreen;
  2.  
  3. {--------------------------------------------------------------------------
  4.   A text screen painting utility to facilitate creation of program screens
  5.   using the Window Library capabilities of the TurboPower Software TpCrt
  6.   unit, and to demonstrate the unit's abilities.
  7.  
  8.   Copyright 1989  Steve Sneed
  9.   CIS IDs  71520,77 or 70007,3574
  10.   Released to the public domain  26-August-89
  11. ---------------------------------------------------------------------------}
  12.  
  13. USES
  14.   TpCrt, TpMouse, TpString, TpEdit;
  15.  
  16. CONST
  17.   MouseActive : Boolean = FALSE;                    { TRUE if mouse in use }
  18.  
  19.   SSFrame     : FrameArray = '┌└┐┘─│';                     { single-single }
  20.   DDFrame     : FrameArray = '╔╚╗╝═║';                     { double-double }
  21.   DSFrame     : FrameArray = '╒╘╕╛═│';                     { double-single }
  22.   SDFrame     : FrameArray = '╓╙╖╜─║';                     { single-double }
  23.  
  24.   CvtMouseSet : Array[$E9..$EF] of Word =
  25.                 ($011B,            { used to convert mouse buttons to keys }
  26.                  $011B,
  27.                  $011B,
  28.                  $011B,
  29.                  $011B,
  30.                  $011B,
  31.                  $1C0D);
  32.  
  33. TYPE
  34.   MakeScrnKeyFunc = FUNCTION : Word;
  35.   ScrRecord       = RECORD
  36.                       Covers : Pointer;
  37.                       C1,C2  : Word;
  38.                     END;
  39.  
  40. VAR
  41.   MyX,MyY     : Byte;
  42.   MakeScrnKey : MakeScrnKeyFunc;
  43.   ScrRec      : ScrRecord;
  44.   PWP         : PackedWindowPtr;
  45.   CurScrFN    : String;
  46.  
  47. PROCEDURE Endit(I : Integer);
  48. BEGIN
  49.   HideMouse;
  50.   NormalCursor;
  51.   ClrScr;
  52.     CASE I of
  53.       0  : ;
  54.       1  : WriteLn('Error allocating memory for screen');
  55.       2  : WriteLn('Error saving screen to library');
  56.       3  : WriteLn('Error reading screen from library');
  57.       else WriteLn('Unknown fatal error');
  58.     END;
  59.   Halt(I);
  60. END;
  61.  
  62.  
  63. PROCEDURE Push;
  64. { save the current screen, set up for a menu request }
  65. BEGIN
  66.   if MouseActive then HideMouse;
  67.   if NOT SaveWindow(1,1,ScreenWidth,ScreenHeight,True,ScrRec.Covers) then EndIt(1);
  68.   GetCursorState(ScrRec.C1,ScrRec.C2);
  69.   HiddenCursor;
  70. END;
  71.  
  72.  
  73. PROCEDURE Pop;
  74. { restore the saved screen }
  75. BEGIN
  76.   RestoreWindow(1,1,ScreenWidth,ScreenHeight,True,ScrRec.Covers);
  77.   RestoreCursorState(ScrRec.C1,ScrRec.C2);
  78.   if MouseActive then ShowMouse;
  79. END;
  80.  
  81.  
  82. PROCEDURE MoveCursor(W : Word);
  83. BEGIN
  84.     CASE Hi(W) of
  85.       71 : GoToXY(1,1);
  86.       72 : GoToXY(WhereX,WhereY - 1);
  87.       75 : GoToXY(WhereX - 1,WhereY);
  88.       77 : GoToXY(WhereX + 1,WhereY);
  89.       79 : GoToXY(ScreenWidth,ScreenHeight);
  90.       80 : GoToXY(WhereX,WhereY + 1);
  91.       else ;
  92.     END;
  93. END;
  94.  
  95.  
  96. FUNCTION MyKey(VAR X,Y : Byte) : Word;
  97. LABEL L01;
  98. { returns the keystroke and the cursor location }
  99. VAR W : Word;
  100. BEGIN
  101. L01:
  102.   W := MakeScrnKey;
  103.   if (Lo(W) = 0) and (Hi(W) >= 71) and (Hi(W) <= 81) then
  104.     BEGIN
  105.       MoveCursor(W);
  106.       if MouseActive then MouseGoToXY(WhereX,WhereY);
  107.       GoTo L01;
  108.     END;
  109.   if (MouseActive) then
  110.     BEGIN
  111.       GoToXY(MouseWhereX,MouseWhereY);
  112.       if (Hi(W) >= $E9) and (Hi(W) <= $EF) then
  113.         W := CvtMouseSet[Hi(W)];
  114.     END;
  115.   X := WhereX;
  116.   Y := WhereY;
  117.   MyKey := W;
  118. END;
  119.  
  120.  
  121. FUNCTION DropAnchor(VAR TX,TY,LX,LY : Byte) : Word;
  122. VAR C  : Char;
  123.     MA : Byte;
  124. BEGIN
  125.   MA := ReadAttrAtCursor;
  126.   C  := ReadCharAtCursor;
  127.   FastWrite('*',TY,TX,MA + 128);
  128.   DropAnchor := MyKey(LX,LY);
  129.   FastWrite(C,TY,TX,MA);
  130. END;
  131.  
  132.  
  133. PROCEDURE DrawFrame;
  134. VAR TX,TY,LX,LY,MA : Byte;
  135.     W              : Word;
  136. BEGIN
  137.   W := MyKey(TX,TY);
  138.   if Lo(W) = 27 then exit;
  139.   W := DropAnchor(TX,TY,LX,LY);
  140.   if Lo(W) = 27 then exit;
  141.   MA := ReadAttrAtCursor;
  142.   FrameWindow(TX,TY,LX,LY,MA,MA,'');
  143. END;
  144.  
  145.  
  146. PROCEDURE EraseArea;
  147. VAR TX,TY,LX,LY : Byte;
  148.     B           : Byte;
  149.     W           : Word;
  150. BEGIN
  151.   W := MyKey(TX,TY);
  152.   if Lo(W) = 27 then exit;
  153.   W := DropAnchor(TX,TY,LX,LY);
  154.   if Lo(W) = 27 then exit;
  155.   for B := TY to LY do
  156.     FastText(CharStr(' ',(LX - TX + 1)),B,TX);
  157. END;
  158.  
  159.  
  160. FUNCTION GetAttrVal(B : Byte) : Byte;
  161. VAR X,Y,N : Byte;
  162.     S     : String;
  163.     E     : Boolean;
  164.     NB    : Integer;
  165. BEGIN
  166.   Push;
  167.   S := HexB(B);
  168.   FrameWindow(62,1,80,19,$1F,$1F,' Colors ');
  169.   X := 64;  Y := 3;
  170.   FastWrite(' 0123456789ABCDEF',2,63,$1F);
  171.   FastVert('0123456789ABCDEF',3,63,$1F);
  172.   for N := 0 to 255 do
  173.     BEGIN
  174.       FastWrite('*',Y,X,N);
  175.       Inc(X);
  176.       if X > 79 then
  177.         BEGIN
  178.           X := 64;
  179.           Inc(Y);
  180.         END;
  181.     END;
  182.     REPEAT
  183.       NB := -1;
  184.       ReadString('New attribute: ',ScreenHeight,1,2,$1F,$1F,$1F,E,S);
  185.       S := '$' + S;
  186.       if (E) or (NOT(Str2Int(S,NB))) or (NB < 0) or (NB > 255) then
  187.         BEGIN
  188.           NB := -1;
  189.           S := HexB(B);
  190.         END;
  191.     UNTIL NB >= 0;
  192.   GetAttrVal := Byte(NB);
  193.   Pop;
  194. END;
  195.  
  196.  
  197. PROCEDURE ChangeAttrArea;
  198. VAR TX,TY,LX,LY : Byte;
  199.     B,NB        : Byte;
  200.     W           : Word;
  201. BEGIN
  202.   W := MyKey(TX,TY);
  203.   if Lo(W) = 27 then exit;
  204.   W := DropAnchor(TX,TY,LX,LY);
  205.   if Lo(W) = 27 then exit;
  206.   NB := GetAttrVal(ReadAttrAtCursor);
  207.   for B := TY to LY do
  208.     ChangeAttribute((LX - TX + 1),B,TX,NB);
  209. END;
  210.  
  211.  
  212. PROCEDURE MoveArea;
  213. VAR SP           : Pointer;
  214.     TX,TY,LX,LY  : Byte;
  215.     NX,NY,B,NB,A : Byte;
  216.     W            : Word;
  217.     PW           : PackedWindowPtr;
  218.     S            : String;
  219. BEGIN
  220.   S := '';
  221.   W := MyKey(TX,TY);
  222.   if Lo(W) = 27 then exit;
  223.   NB := ReadAttrAtCursor;
  224.   if WhereX > 1 then
  225.     ReadAttribute(1,WhereY,WhereX - 1,S)
  226.   else if WhereY > 1 then
  227.     ReadAttribute(1,WhereY - 1,WhereX,S);
  228.   W := DropAnchor(TX,TY,LX,LY);
  229.   if (Lo(W) = 27) then exit;
  230.   if S = '' then
  231.     BEGIN
  232.       if WhereX < ScreenWidth then
  233.         ReadAttribute(1,WhereY,WhereX + 1,S)
  234.       else if WhereY < ScreenHeight then
  235.         ReadAttribute(1,WhereY + 1,WhereX,S);
  236.     END;
  237.   if S <> '' then NB := Ord(S[1]);
  238.   PW := PackWindow(TX,TY,LX,LY);
  239.   if PW = NIL then exit;
  240.   W := MyKey(NX,NY);
  241.   if Lo(W) = 27 then exit;
  242.   for B := TY to LY do
  243.     FastWrite(CharStr(' ',(LX - TX + 1)),B,TX,NB);
  244.   DispPackedWindowAt(PW,NY,NX);
  245. END;
  246.  
  247. PROCEDURE InputText;
  248. VAR TX,TY,LX,LY,MA : Byte;
  249.     W              : Word;
  250. BEGIN
  251.   W := MyKey(TX,TY);
  252.   if Lo(W) = 27 then exit;
  253.   if MouseActive then
  254.     BEGIN
  255.       HideMouse;
  256.       NormalCursor;
  257.     END;
  258.     REPEAT
  259.       W := MyKey(TX,TY);
  260.         CASE Lo(W) of
  261.           0  : MoveCursor(W);
  262.           8  : BEGIN
  263.                  FastWrite(' ',TY,TX,ReadAttrAtCursor);
  264.                  if TX > 1 then Dec(TX);
  265.                  GoToXY(TX,TY);
  266.                  MouseGoToXY(TX,TY);
  267.                END;
  268.        1..31 : ;
  269.           else BEGIN
  270.                  FastWrite(Char(Lo(W)),TY,TX,ReadAttrAtCursor);
  271.                  if TX < ScreenWidth then Inc(TX);
  272.                  GoToXY(TX,TY);
  273.                  MouseGoToXY(TX,TY);
  274.                END;
  275.         END;
  276.     UNTIL (Lo(W) = 27);
  277.   if MouseActive then
  278.     ShowMouse;
  279.   BlockCursor;
  280. END;
  281.  
  282.  
  283. PROCEDURE View;
  284. VAR X,Y : Byte;
  285. BEGIN
  286.   REPEAT UNTIL MyKey(X,Y) <> $FFFF;
  287. END;
  288.  
  289.  
  290. FUNCTION SaveThisScreen : Boolean;
  291. VAR S : String;
  292.     E : Boolean;
  293. BEGIN
  294.   SaveThisScreen := FALSE;
  295.   Push;
  296.   PWP := PackWindow(1,1,ScreenWidth,ScreenHeight);
  297.   if PWP = NIL then
  298.     BEGIN
  299.       Pop;
  300.       exit;
  301.     END;
  302.   S := '';
  303.   ReadString('Filename for this screen: ',ScreenHeight,1,12,$1F,$1F,$1F,E,S);
  304.   if S = '' then
  305.     BEGIN
  306.       Pop;
  307.       exit;
  308.     END;
  309.   CurScrFN := StUpcase(S);
  310.   WritePackedWindow(PWP,S);
  311.   SaveThisScreen := (CrtError = 0);
  312.   Pop;
  313. END;
  314.  
  315.  
  316. FUNCTION LoadThisScreen(UseCurScrFN : Boolean) : Boolean;
  317. VAR S : String;
  318.     E : Boolean;
  319. BEGIN
  320.   LoadThisScreen := FALSE;
  321.   if NOT UseCurScrFN then
  322.     BEGIN
  323.       Push;
  324.       S := '';
  325.       ReadString('Screen file to read: ',ScreenHeight,1,12,$1F,$1F,$1F,E,S);
  326.       if S = '' then
  327.         BEGIN
  328.           Pop;
  329.           exit;
  330.         END;
  331.       CurScrFN := StUpCase(S);
  332.       Pop;
  333.     END;
  334.   PWP := ReadPackedWindow(CurScrFN);
  335.   if PWP = NIL then exit;
  336.   DispPackedWindow(PWP);
  337.   LoadThisScreen := True;
  338. END;
  339.  
  340.  
  341. PROCEDURE NewFrameSet;
  342. VAR I : Integer;
  343.     E : Boolean;
  344.     S : String[6];
  345. BEGIN
  346.   Push;
  347.   S := '      ';
  348.   Move(FrameChars[ULeft],S[1],6);
  349.   FrameWindow(72,1,80,6,$1F,$1F,'');
  350.   FastVert('1234',2,73,$1F);
  351.   Move(SSFrame[ULeft],S[1],6);
  352.   FastWrite(S,2,74,$1F);
  353.   Move(DDFrame[ULeft],S[1],6);
  354.   FastWrite(S,3,74,$1F);
  355.   Move(DSFrame[ULeft],S[1],6);
  356.   FastWrite(S,4,74,$1F);
  357.   Move(SDFrame[ULeft],S[1],6);
  358.   FastWrite(S,5,74,$1F);
  359.   I := 3;
  360.   ReadInteger('New frame set (1 - 4): ',ScreenHeight,1,1,$1F,$1F,1,4,E,I);
  361.     CASE I of
  362.       1 : FrameChars := SSFrame;
  363.       2 : FrameChars := DDFrame;
  364.       3 : FrameChars := DSFrame;
  365.       4 : FrameChars := SDFrame;
  366.     END;
  367.   Pop;
  368. END;
  369.  
  370.  
  371. FUNCTION Menu : Char;
  372. VAR I : Integer;
  373.     W : Word;
  374. BEGIN
  375.   HiddenCursor;
  376.   if MouseActive then HideMouse;
  377.   Push;
  378.   FrameWindow(58,1,80,12,$1F,$1F,' MakeScreen Menu ');
  379.   For I := 2 to 11 do FastWrite(CharStr(' ',21),I,59,$1F);
  380.   FastWrite('Change attributes',2,60,$17);
  381.   FastWrite('Draw frame',3,60,$17);
  382.   FastWrite('Erase area',4,60,$17);
  383.   FastWrite('Frame chars change',5,60,$17);
  384.   FastWrite('Input text',6,60,$17);
  385.   FastWrite('Load from Library',7,60,$17);
  386.   FastWrite('Move region',8,60,$17);
  387.   FastWrite('Save to Library',9,60,$17);
  388.   FastWrite('View screen',10,60,$17);
  389.   FastWrite('Quit',11,60,$17);
  390.   For I := 2 to 11 do ChangeAttribute(1,I,60,$1F);
  391.     REPEAT
  392.       W := ReadKeyWord;
  393.     UNTIL Upcase(Chr(Lo(W))) in ['C','D','E','F','I','L','M','Q','S','V'];
  394.   Menu := Upcase(Chr(Lo(W)));
  395.   Pop;
  396.   if MouseActive then ShowMouse;
  397.   BlockCursor;
  398. END;
  399.  
  400.  
  401. PROCEDURE InitMakeScreen;
  402. BEGIN
  403.   ClrScr;
  404.   FrameChars := DSFrame;
  405.   if ParamCount = 0 then CurScrFN := '' else
  406.     BEGIN
  407.       CurScrFN := StUpCase(ParamStr(1));
  408.       if NOT LoadThisScreen(TRUE) then EndIt(2);
  409.     END;
  410.   BlockCursor;
  411.   if MouseInstalled then
  412.     BEGIN
  413.       MouseActive := TRUE;
  414.       MakeScrnKey := ReadKeyOrButton;
  415.       EnableEventHandling;
  416.       BlockMouseCursor;
  417.       ShowMouse;
  418.     END
  419.   else MakeScrnKey := ReadKeyWord;
  420. END;
  421.  
  422.  
  423. PROCEDURE MakeTheScreen;
  424. VAR C : Char;
  425. BEGIN
  426.   InitMakeScreen;
  427.     REPEAT
  428.       C := Menu;
  429.         CASE C of
  430.           'Q': EndIt(0);
  431.           'C': ChangeAttrArea;
  432.           'I': InputText;
  433.           'D': DrawFrame;
  434.           'E': EraseArea;
  435.           'F': NewFrameSet;
  436.           'M': MoveArea;
  437.           'V': View;
  438.           'S': if NOT SaveThisScreen then EndIt(2);
  439.           'L': if NOT LoadThisScreen(FALSE) then EndIt(3);
  440.           else ;
  441.         END;
  442.     UNTIL False;
  443. END;
  444.  
  445.  
  446. BEGIN
  447.   MakeTheScreen;
  448. END.
  449.